home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Monster Media 1996 #14
/
Monster Media No. 14 (April 1996) (Monster Media, Inc.).ISO
/
prog_d
/
isamexpt.zip
/
ISAMBROW.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1996-01-13
|
21KB
|
588 lines
unit Isambrow;
{copyright 1995 by Norbert Stellberg GmbH,
parts that are signed with a "*" copyright by TURBO POWER
or Michael Williams CompuServe: 71552,757 }
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, ExtCtrls, Fvcbrows, Filer, IsamTabl;
type
Feld_GetProc = Function(Feld: Integer;
Table: TIsamTable;
var DATA): String;
{FELD_GETPROC will be created by the expert in
the browser-unit.
It will get the data-fields from your record.
Example:
Function TestGetFeldProc(Feld: Integer; Table: TIsamTable; var DATA): String; far;
var S: String;
begin
S:= '';
With TESTRECORD(Data) do begin
Case Feld of
1: s:= String_oem2ansi(Table.AnsiConvert,NAME1)+'^';
2: s:= String_oem2ansi(Table.AnsiConvert,NAME2)+'^';
3: s:= String_oem2ansi(Table.AnsiConvert,STREET)+'^';
4: s:= String_oem2ansi(Table.AnsiConvert,ZIP)+'^';
5: s:= String_oem2ansi(Table.AnsiConvert,CITY)+'^';
6: s:= DateStr(DATE)+'^';
7: s:= FormDezStr(AGE,10);
end;
end;
Result:= S;
end; }
TIsamBrowser = class(TFvcBrowser)
{a descendant of the TFVCBROWSER-Object, whose copyright is
by TURBO POWER INC.
Vars and Procs, signed by a "*" are copied from the TFVCBROWSER.
the copyright will still be held by TURBO POWER}
private
{ Private declarations }
FHeader : THeader; {a normal header for your browser}
FSpalten : TStringList; {a list of TUEBERSCHRIFTOBJECTS .. see ISBRINST.INT}
FTable : TIsamTable; {the isamtable, that will be browsed}
FKeySection : integer; { * Which header section are we searching on }
FSeparatorChar : char; { * Default '^' }
FJustLeftChar : char; { * Default #255 }
FJustRightChar : char; { * Default #255 }
FJustCenterChar : char; { * Default #255 }
FAllowIncss : boolean; { * }
FIncSSColor : TColor; { * }
FIncSSTxtColor : TColor; { * }
Procedure SetTable(const Value: TIsamTable);
Procedure SetSpalten(const Value: TStringList);
protected
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
procedure KeyPress(var Key: Char); override;
function WriteStringOut(var S : string;
LineNr : word;
XOfs : integer): word; override;
procedure ShowErrorOccured(EClass: Integer); override;
public
BaseLKey : IsamKeyStr; { * }
BaseHKey : IsamKeyStr; { * }
IncSS : IsamKeyStr; { * Incremental search string }
FTextMargin : TRect; { * }
Procedure ResizeHeader; {must be called after you changed the
field widths by drag and drop in your
browser}
Function ReadIni: Integer; {will read browser-settings from an ini-file,
{must be called after creating the form and
before showing the browser-form.}
Procedure SetupBrowser(aParent: TForm); {will show the browser-setup-dialog,
see ISBRINST.INT}
Function GetRow(GetProc: Feld_GetProc; var DATA):String;
{called by the browser to show the data fields}
Function GetLowBrowser: PLowWinBrowser;
published
{ Published declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property BrowserHeader : THeader read FHeader write FHeader;
property Spalten : TStringList read FSpalten write SetSpalten;
property Table : TIsamTable read FTable write SetTable;
property KeySection : {*}integer read FKeySection write FKeySection;
property SeparatorChar : {*}char read FSeparatorChar write FSeparatorChar;
property JustLeftChar : {*}char read FJustLeftChar write FJustLeftChar;
property JustRightChar : {*}char read FJustRightChar write FJustRightChar;
property JustCenterChar : {*}char read FJustCenterChar write FJustCenterChar;
property AllowIncSS : {*}boolean read FAllowIncSS write FAllowIncSS;
property IncSSColor : {*}TColor read FIncSSColor write FIncSSColor;
property IncSSTxtColor : {*}TColor read FIncSSTxtColor write FIncSSTxtColor;
procedure ClearIncss; {*}
end;
procedure Register;
Function GetAppName: String; {procedure, to get the name of your application during runtime}
implementation
Uses UToolDll, IniFiles, IsBrInst;
Var AppName: String;
Function GetAppName: String;
var G: String;
xPos: Integer;
begin
G:= Application.ExeName;
xPos:= Pos('\',G);
While xPos > 0 do begin
Delete(G,1,xPos);
xPos:= Pos('\',G);
end;
xPos:= Pos('.',G);
if xPos > 0 then G:= Copy(G,1,xPos-1);
AppName:= G;
GetAppName:= G;
end;
constructor TIsamBrowser.Create(AOwner : TComponent);
begin
Inherited Create(AOwner);
IncSS := '';
SeparatorChar := '^';
FJustLeftChar := #255;
FJustCenterChar := #255;
FJustRightChar := #255;
BaseLKey := LowKey;
BaseHKey := HighKey;
FIncSSColor := clRed;
FIncssTxtColor := clWhite;
FSpalten:= TStringList.Create;
end;
Function TIsamBrowser.GetLowBrowser: PLowWinBrowser;
begin
Result:= BrowserPtr;
end;
Destructor TIsamBrowser.Destroy;
begin
FSpalten.Free;
Inherited Destroy;
end;
Function TIsamBrowser.ReadIni: Integer;
var BrwListe,SListe: TStringList;
BrwIni: TIniFile;
FNr,K,i,Code,idx,Arr1,Arr2,Feld: Integer;
SStr,AktDir,LStr,LenStr,FeldName: String;
x,Len: Longint;
begin
AktDir:= ExtractFilePath(Application.ExeName);
K:= 1;
BrwIni:= TIniFile.Create(AktDir + GetAppName+'.INI');
BrwListe:= TStringList.Create;
SListe:= TStringList.Create;
K:= BrwIni.ReadInteger(Name+'Key','KeyNo',1);
BrwIni.ReadSection(Name,BrwListe);
if BrwListe.Count > 0 then begin
For i:= 0 to BrwListe.Count-1 do begin
LStr:= BrwIni.ReadString(Name,BrwListe[i],'');
if Pos(',',LStr) > 0 then begin
Val(Copy(LStr,1,Pos(',',LStr)-1),Len,Code);
Delete(LStr,1,Pos(',',LStr));
Val(LStr,Idx,Code);
end
else begin
Idx:= i+1;
Val(LStr,Len,Code);
end;
SListe.AddObject(BrwListe[i],TUeberschriftObject.Init(BrwListe[i],Idx,Len));
end;
Spalten:= SListe;
end
else begin
if Table <> NIL then begin
if Table.IsamRecord.Count > 0 then begin
FNr:= 0;
For i:= 0 to Table.IsamRecord.Count-1 do begin
SStr:= Table.IsamRecord[i];
if (Pos('DUMMY',Uppercase(SStr)) = 0) and (Pos('IGNORE',Uppercase(SStr)) = 0) then begin
Len:= 0;
if Pos(':',SStr) > 0 then begin
GetArray(SStr,Arr1,Arr2);
For Feld:= Arr1 to Arr2 do begin
FeldName:= Copy(SStr,1,Pos(':',SStr)-1);
Strip(FeldName);
if Arr1 <> Arr2 then FeldName:= FeldName + DezStr(Feld);
LenStr:= Uppercase(SStr);
Delete(LenStr,1,Pos(':',LenStr));
Strip(LenStr);
if Pos('ARRAY[',LenStr) > 0 then begin
Delete(LenStr,1,Pos('ARRAY[',LenStr));
Delete(LenStr,1,Pos(']',LenStr));
end;
if Pos('STRING',LenStr) > 0 then begin
if Pos('[',LenStr) > 0 then begin
Delete(LenStr,1,Pos('[',LenStr));
LenStr:= Copy(LenStr,1,Pos(']',LenStr)-1);
Val(LenStr,Len,Code);
end
else Len:= 255;
end
else if Pos('INTEGER',LenStr) > 0 then Len:= 8
else if Pos('WORD',LenStr) > 0 then Len:= 8
else if Pos('BYTE',LenStr) > 0 then Len:= 4
else if Pos('LONGINT',LenStr) > 0 then Len:= 10
else if Pos('REAL',LenStr) > 0 then Len:= 10;
{if Len > 0 then begin}
Inc(FNr);
SListe.AddObject(FeldName,TUeberschriftObject.Init(FeldName,FNr,Len));
{end;}
end;
end;
end;
end;
Spalten:= SListe;
end;
end;
end;
SListe.Free;
BrwListe.Free;
BrwIni.Free;
Result:= K;
end;
(*Function TIsamBrowser.GetRow(GetProc: Feld_GetProc; var DATA):String;
var S: String;
i,X,Code: Integer;
U:TUeberschriftObject;
begin
S:= '';
For i:= 0 to Spalten.Count-1 do begin
if Spalten.Objects[i] <> NIL then begin
U:= TUeberschriftObject(Spalten.Objects[i]);
X:= U.Idx;
if (X > 0) and (U.Breite > 0) then S:= S + GetProc(X,Table,DATA);
end;
end;
Result:= ' '+S+#13
end;*)
Function TIsamBrowser.GetRow(GetProc: Feld_GetProc; var DATA):String;
var S: String;
ss : String; {NS}
i,X,Code : Integer;
L,ii: Integer; {NS}
U:TUeberschriftObject;
SChar: Char;
begin
S:= '';
SChar:= SeparatorChar;
For i:= 0 to Spalten.Count-1 do begin
if Spalten.Objects[i] <> NIL then begin
U:= TUeberschriftObject(Spalten.Objects[i]);
X:= U.Idx;
L := U.Breite; {NS}
ss := GetProc(X,Table,DATA); {NS}
ii := Pos(SChar,ss); {NS}
if ii > 0 then delete(ss,ii,1); {NS}
ss := F(SS,L)+SChar; {NS} {Ich bin davon ausgegangen, da▀ das Feld die LΣnge L hat zuzⁿglich das Zeichen
^. Das Zeichen ^ habe ich entfernt, den String auf die LΣnge L aufgefⁿllt und das Zeichen
^ wieder angefⁿgt. Beachte bitte, das das Zeichen ^ variabel ist und im Browser eingestellt
werden kann. }
if (X > 0) and (U.Breite > 0) then S:= S + ss; {NS}
end;
end;
Result:= ' '+S+#13
end;
Procedure TIsamBrowser.SetupBrowser(aParent: TForm);
begin
BrowserSetup(aParent,GetAppName,Name,Table);
ReadIni;
SetAndUpDateBrowserScreen('',0);
end;
Procedure TIsamBrowser.SetTable(Const Value: TIsamTable);
var FNr,i,Len,Code,Feld,Arr1,Arr2: Integer;
SStr,FeldName,LenStr: String;
SListe: TStringList;
begin
FTable:= Value;
if (csDesigning in ComponentState) then begin
if Assigned(Value) then begin
if FSpalten.Count = 0 then begin
if Value.IsamRecord.Count > 0 then begin
SListe:= TStringList.Create;
FNr:= 0;
For i:= 0 to Value.IsamRecord.Count-1 do begin
SStr:= Value.IsamRecord[i];
if (Pos('DUMMY',Uppercase(SStr)) = 0) and (Pos('IGNORE',Uppercase(SStr)) = 0) then begin
Len:= 0;
if Pos(':',SStr) > 0 then begin
GetArray(SStr,Arr1,Arr2);
For Feld:= Arr1 to Arr2 do begin
FeldName:= Copy(SStr,1,Pos(':',SStr)-1);
Strip(FeldName);
if Arr1 <> Arr2 then FeldName:= FeldName + DezStr(Feld);
LenStr:= Uppercase(SStr);
Delete(LenStr,1,Pos(':',LenStr));
Strip(LenStr);
if Pos('ARRAY[',LenStr) > 0 then begin
Delete(LenStr,1,Pos('ARRAY[',LenStr));
Delete(LenStr,1,Pos(']',LenStr));
end;
if Pos('STRING',LenStr) > 0 then begin
if Pos('[',LenStr) > 0 then begin
Delete(LenStr,1,Pos('[',LenStr));
LenStr:= Copy(LenStr,1,Pos(']',LenStr)-1);
Val(LenStr,Len,Code);
end
else Len:= 255;
end
else if Pos('INTEGER',LenStr) > 0 then Len:= 8
else if Pos('WORD',LenStr) > 0 then Len:= 8
else if Pos('BYTE',LenStr) > 0 then Len:= 4
else if Pos('LONGINT',LenStr) > 0 then Len:= 10
else if Pos('REAL',LenStr) > 0 then Len:= 10;
{if Len > 0 then begin}
Inc(FNr);
SListe.AddObject(FeldName,TUeberschriftObject.Init(FeldName,FNr,Len));
{end;}
end;
end;
end;
end;
Spalten:= SListe;
SListe.Free;
end;
end;
end;
end;
end;
procedure TIsamBrowser.SetSpalten(const Value: TStringList);
var N,i,xLen,Code: Integer;
SStr,TStr: String;
begin
FSpalten.Assign(Value);
if BrowserHeader <> NIL then BrowserHeader.Sections.Clear;
if Value <> NIL then begin
if FSpalten.Count > 0 then begin
n:= 0;
for i:= 0 to FSpalten.Count-1 do begin
if FSpalten.Objects[i] <> NIL then begin
with TUeberschriftObject(FSpalten.Objects[i]) do begin
SStr:= Txt;
xLen:= Breite;
if xLen > 0 then begin
if BrowserHeader <> NIL then begin
BrowserHeader.Sections.Insert(N,SStr);
BrowserHeader.SectionWidth[N]:= (xLen * 7)+8;
inc(N);
end;
end;
end;
end;
end;
end;
end;
end;
Procedure TIsamBrowser.ResizeHeader;
var idx,I,K,Len,x: Integer;
AktDir,SStr: String;
SListe: TStringList;
BrwIni: TIniFile;
U: TUeberschriftObject;
begin
AktDir:= ExtractFilePath(Application.ExeName);
if BrowserHeader <> NIL then begin
if BrowserHeader.Sections.Count > 0 then begin
SListe:= TStringList.Create;
BrwIni:= TIniFile.Create(AktDir + GetAppname+'.INI');
if Table <> NIL then K:= Table.KeyNo else K:= 1;
BrwIni.WriteInteger(Name+'Key','KeyNo',K);
if Spalten.Count > 0 then begin
for i:= 0 to Spalten.Count-1 do begin
if Spalten.Objects[i] <> NIL then begin
U:= TUeberschriftObject(Spalten.Objects[i]);
x:= BrowserHeader.Sections.Indexof(Spalten[i]);
if x > -1 then begin
Len:= Round((BrowserHeader.SectionWidth[x]-8)/7);
if Len < 0 then Len:= 0;
SStr:= BrowserHeader.Sections[x];
Idx:= U.Idx;
SListe.AddObject(SStr, TUeberschriftObject.Init(SStr,idx,Len));
SStr:= DezStr(Len)+','+DezStr(idx);
if Len > 0 then BrwIni.WriteString(Name,BrowserHeader.Sections[x],SStr);
end
else begin
SStr:= U.Txt;
Len:= U.Breite;
Idx:= U.idx;
SListe.AddObject(SStr,TueberschriftObject.Init(SStr,idx,Len));
end;
end
else Errorwindow('Object is NIL',Spalten[i]);
end;
end
else Errorwindow('Spalte is NIL','');
Spalten:= SListe;
SListe.Free;
BrwIni.Free;
end;
end;
ReadIni;
SetAndUpdateBrowserScreen('', 0);
end;
procedure TIsamBrowser.ShowErrorOccured(EClass: Integer);
begin
if EClass > 1 then Inherited showErrorOccured(EClass);
end;
procedure TIsamBrowser.ClearIncSS;
begin
{ Make sure to call this before going to a new key number }
IncSS := '';
LowKey := BaseLKey;
HighKey := BaseHKey;
end;
function TIsamBrowser.WriteStringOut(var S : string;
LineNr : word;
XOfs : integer) : word;
var
SegmentString : string;
Just,i,j : integer;
Rect : TRect;
x : integer;
SegNum : integer;
SaveFontColor,
SaveColor : TColor;
function StUpCase(St : string) : string;
var i : integer;
begin
Result := st;
for i := 1 to length(st) do result[i] := upcase(result[i]);
end;
begin
Result := GetTextOutPosY(LineNr);
Rect.Left := 0{1};
Rect.Top := Result;
Rect.Bottom := Result + TotalCharHeight;
if Assigned(FHeader) then
Rect.Right := BrowserHeader.Width
else
Rect.Right := Width;
Canvas.FillRect(Rect);
SegmentString := '';
SegNum := 0;
if Assigned(FHeader) then begin
BrowserHeader.Left := xOfs + Left;
BrowserHeader.Width := Width - xOfs;
end;
Just := DT_Left;
for i := 1 to length(S) do begin
if (S[i] = JustLeftChar) then Just := DT_left else
if (S[i] = JustCenterChar) then Just := DT_Center else
if (S[i] = JustRightChar) then Just := DT_Right else
if (S[i] = SeparatorChar) or (i = length(S)) then begin
if i = length(S) then SegmentString := SegmentString + S[i];
{ SegmentString now contains the segment }
Rect.Top := Result;
Rect.Bottom := Result + TotalCharHeight;
x := 1;
if Assigned(FHeader) then begin
for j := 0 to SegNum-1 do
x := x + BrowserHeader.SectionWidth[j];
Rect.Left := XOfs + FTextMargin.Left + x + 2;
if SegNum = BrowserHeader.Sections.Count-1 then
Rect.Right := Rect.Left + BrowserHeader.SectionWidth[SegNum]-20
else
Rect.Right := Rect.Left + BrowserHeader.SectionWidth[SegNum]-4;
end else begin
Rect.Left := XOfs + FTextMargin.Left + 2;
Rect.Right := XOfs + FtextMargin.Left + Width - 2;
end;
{ Draw the text }
DrawText(Canvas.Handle,@SegmentString[1],length(SegmentString),Rect,Just+DT_NoPrefix);
{ Process the incremental search string }
if (IncSS <> '') and (SegNum = KeySection) and (Just = DT_Left) and
(copy(StUpCase(SegmentString),1,Length(IncSS)) = IncSS) then begin
{ Do incremental search string highlight }
SaveColor := Canvas.Brush.Color;
SaveFontColor := Canvas.Font.Color;
Canvas.Font.Color := IncSSTxtColor;
Canvas.Brush.Color := IncSSColor;
DrawText(Canvas.Handle,@SegmentString[1],length(IncSS),Rect,DT_Left+Dt_NoPrefix);
Canvas.Font.Color := SaveFontColor;
Canvas.Brush.Color := SaveColor;
end;
{ Draw vertical lines }
Canvas.Pen.Color := clGray;
Rect.Right := Rect.Right + 2;
Canvas.MoveTo(Rect.Right-2,Rect.Top);
Canvas.LineTo(Rect.Right-2,Rect.Bottom);
Canvas.Pen.Color := clWhite;
Canvas.MoveTo(Rect.Right-1,Rect.Top);
Canvas.LineTo(Rect.Right-1,Rect.Bottom);
inc(SegNum);
SegmentString := '';
end else begin
SegmentString := SegmentString + S[i];
end;
end;
end;
procedure TIsamBrowser.KeyDown(var Key: Word; Shift: TShiftState);
var Data,Dup: Pointer;
begin
inherited KeyDown(Key, Shift);
if CanCallLowBrowser then begin
case Key of
vk_Delete: if Table <> NIL then begin
Table.Ref:= GetCurrentDatRef;
GetMem(Data,Table.RecSize);
GetMem(Dup,Table.RecSize);
Table.Get(Data^,Dup^);
Table.Delete(Data^,Dup^);
FreeMem(Dup,Table.RecSize);
FreeMem(Data,Table.RecSize);
SetAndUpdateBrowserScreen(Table.Key,Table.Ref);
end;
vk_Insert: OnDblClick(Self);
end;
end;
end;
procedure TIsamBrowser.KeyPress(var Key : char);
Const AllowedKeys = [' '..'z'];
var SaveIncSS, SaveLowKey, SaveHighKey : IsamKeyStr;
begin
if not AllowIncss then Exit;
SaveIncSS := IncSS;
if Key = #8 then begin { Backspace }
if IncSS <> '' then Delete(IncSS,Length(IncSS),1);
end else begin
if Key in AllowedKeys then IncSS := IncSS + UpCase(Key)
else begin
Messagebeep(0);
Exit;
end;
end;
if not CanCallLowBrowser then Exit;
{ Changing either the low or the high key can cause use to not have any
records left to show, so if either fails, we need to undo the changes. }
try
SaveLowKey := LowKey;
LowKey := BaseLKey + IncSS;
try
SaveHighKey := HighKey;
HighKey := BaseHKey + IncSS;
except
HighKey := SaveHighKey;
LowKey := SaveLowKey;
IncSS := SaveIncSS;
MessageBeep(0);
end;
except
LowKey := SaveLowKey;
IncSS := SaveIncSS;
MessageBeep(0);
end;
end;
procedure Register;
begin
RegisterComponents('B-Tree Filer', [TIsamBrowser]);
end;
end.